VBA获取指定文件夹下所有文件和子文件目录的文件 |
您所在的位置：网站首页 › vba 打开指定文件夹下的所有工作簿文件 › VBA获取指定文件夹下所有文件和子文件目录的文件 |
VBA获取指定文件夹下所有文件和子文件目录的文件
|
公司运营部门需要把影像资料梳理一遍，文件目录特别多，文件量也大，大概40多个G。自己写了一个读取目录下所有子文件的脚本 开始参考了 VBA获取某文件夹下所有文件和子文件目录的文件中的代码，按照此方式获取的结果有问题。 问题1 无法获取目录名中包含“.”的子目录 '-- 获得所有子目录 Do Until i > k f = Dir(file(i), vbDirectory) Do Until f = "" If InStr(f, ".") = 0 Then k = k + 1 ReDim Preserve file(1 To k) file(k) = file(i) & f & "\" End If f = Dir Loop i = i + 1 Loop代码中使用InStr(f, “.”) = 0 判断，只要名字中包含"."就按照文件处理 问题2 无法获取扩展名为空的文件 '-- 获得所有子目录下的所有文件 For i = 1 To k f = Dir(file(i) & "*.*") '通配符*.*表示所有文件，*.xlsx Excel文件 Do Until f = "" 'Range("a" & x) = f Range("a" & x).Hyperlinks.Add Anchor:=Range("a" & x), Address:=file(i) & f, TextToDisplay:=f x = x + 1 f = Dir Loop Next于是，自己实现了一个支持文件夹名称带“.”或文件名不带扩展名的。 实现过程 新建一个文件，在sheet1中增加两个按钮，一个用来选取文件夹，一个用来执行查询 选择文件脚本 Option Explicit Sub 打开文件夹() With Application.FileDialog(msoFileDialogFolderPicker) If .Show = -1 Then Worksheets("Sheet1").Range("C5").Value = .SelectedItems(1) End If End With End Sub 执行脚本 Sub 按钮1_Click() On Error Resume Next Dim folderObj As Object Dim currFolder Dim fdCnt As Integer Dim sDir As String Dim dirExist, f As String Dim file(), subFolder(), allfd() As String Dim fileNum, k, x, idx, i, j, listNum Dim threeDir As String fileNum = 1 x = 1 k = 1 j = 0 i = 1 sDir = Worksheets("Sheet1").Range("C5").Value '=== 0.清除数据============================================= Sheet2.UsedRange.Clear Worksheets("Sheet2").Range("A1").Value = "序号" Worksheets("Sheet2").Range("C1").Value = "文件名" Worksheets("Sheet2").Range("D1").Value = "文件路径" Worksheets("Sheet2").Range("E1").Value = "文件格式" Worksheets("Sheet2").Range("E1").Interior.Color = RGB(255, 255, 0) Worksheets("Sheet2").Range("A1").Interior.Color = RGB(255, 255, 0) Worksheets("Sheet2").Range("C1").Interior.Color = RGB(255, 255, 0) Worksheets("Sheet2").Range("D1").Interior.Color = RGB(255, 255, 0) Worksheets("Sheet2").Range("E1").Borders.LineStyle = xlContinuous Worksheets("Sheet2").Range("A1").Borders.LineStyle = xlContinuous Worksheets("Sheet2").Range("C1").Borders.LineStyle = xlContinuous Worksheets("Sheet2").Range("D1").Borders.LineStyle = xlContinuous '=== 1.判断选择的文件夹是否有效=============================== dirExist = dir(sDir, vbDirectory) If dirExist = "" Then MsgBox ("选择的文件夹无效") Exit Sub End If '=== 2.获取所有子目录====================================== ReDim subFolder(1 To i) subFolder(1) = sDir & "\" f = dir(subFolder(1), vbDirectory) Do Until f = "" If f "." And f ".." Then If (GetAttr(subFolder(1) & f) And vbDirectory) = 16 Then 'Worksheets("Sheet3").Range("A" & k).Value = subFolder(1) & f & "\" k = k + 1 ReDim Preserve subFolder(1 To k) subFolder(k) = subFolder(1) & f & "\" End If End If f = dir Loop i = i + 1 Dim tmp As Integer tmp = 0 For Each fd In subFolder tmp = tmp + 1 ReDim Preserve allfd(1 To tmp) i = 1 k = 1 Erase file ReDim file(1 To i) file(i) = fd allfd(tmp) = fd Worksheets("Sheet3").Range("B" & tmp).Value = allfd(tmp) If subFolder(1) = file(i) Then f = dir i = i + 1 Else Do Until i > k f = dir(file(i), vbDirectory) Do Until f = "" If f "." And f ".." Then If (GetAttr(file(i) & f) And vbDirectory) = 16 Then k = k + 1 ReDim Preserve file(1 To k) file(k) = file(i) & f & "\" tmp = tmp + 1 ReDim Preserve allfd(1 To tmp) allfd(tmp) = file(i) & f & "\" ' Worksheets("Sheet3").Range("B" & tmp).Value = allfd(tmp) End If End If f = dir Loop i = i + 1 Loop End If Next '=== 3.获取所有子目录下的文件====================================== ' Dim threeStr As String x = 2 idx = 1 For i = 1 To tmp f = dir(allfd(i) & "*.*") Do Until f = "" Worksheets("Sheet2").Range("A" & x).Value = idx Worksheets("Sheet2").Range("C" & x).Value = f Worksheets("Sheet2").Range("D" & x).Value = Replace(allfd(i), sDir, "") & f 'Worksheets("Sheet2").Range("E" & x).Value = getFileType(f) 'Worksheets("Sheet2").Range("B" & x).NumberFormatLocal = "@" 'Worksheets("Sheet2").Range("B" & x).Value = getToubaodanHao(sDir, allfd(i)) f = dir x = x + 1 idx = idx + 1 Loop Next End Sub最终效果： |
【本文地址】
今日新闻 |
推荐新闻 |